home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / ilisp / lucid.lisp < prev    next >
Encoding:
Text File  |  1995-01-26  |  2.5 KB  |  86 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; lucid.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.7
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995 Marco Antoniotti and Rick Busdiecker
  11. ;;;
  12. ;;; Other authors' names for which this Copyright notice also holds
  13. ;;; may appear later in this file.
  14. ;;;
  15. ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
  16. ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
  17. ;;; mailing list were bugs and improvements are discussed.
  18. ;;;
  19. ;;; ILISP is freely redistributable under the terms found in the file
  20. ;;; COPYING.
  21.  
  22.  
  23.  
  24. ;;; Lucid initializations 
  25. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  26. ;;;
  27. (in-package "ILISP")
  28.  
  29. ;;;
  30. (defun ilisp-callers (symbol package &aux (list-of-callers nil))
  31.   "Print the callers of PACKAGE::SYMBOL.  Only compiled functions
  32. currently.  Return T if successful."
  33.   (ilisp-errors
  34.    (let ((function-name (ilisp-find-symbol symbol package))
  35.      (*print-level* nil)
  36.      (*print-length* nil)
  37.      (*package* (find-package 'lisp)))
  38.      (when (and function-name (fboundp function-name))
  39.        (flet
  40.        ((check-symbol (symbol)
  41.           (labels
  42.           ((check-function (function &optional exclusions)
  43.              (do ((i 4 (1+ i)))
  44.              ((>= i (lucid::procedure-length function)))
  45.                (let ((element (sys:procedure-ref function i)))
  46.              (cond ((eq element function-name)
  47.                 (pushnew symbol list-of-callers))
  48.                    ((and (compiled-function-p element)
  49.                      (not (find element exclusions)))
  50.                 (check-function
  51.                  element
  52.                  (cons element exclusions))))))))
  53.         (check-function (symbol-function symbol)))))
  54.      (do-all-symbols (symbol)
  55.        (when (fboundp symbol)
  56.          (check-symbol symbol)))
  57.      (dolist (caller list-of-callers)
  58.        (print caller))
  59.      t)))))
  60.  
  61. ;;;
  62. (defun ilisp-source-files (symbol package type)
  63.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  64. return T if successful."
  65.   (ilisp-errors
  66.    (let* ((symbol (ilisp-find-symbol symbol package))
  67.       (all (equal type "any"))
  68.       (type (unless all (ilisp-find-symbol type package)))
  69.       (paths (when symbol
  70.            (lucid::get-source-file symbol type all))))
  71.      (if paths
  72.      (progn
  73.        (if all
  74.            (dolist (file (remove-duplicates paths
  75.                         :key #'cdr :test #'equal))
  76.          (print (namestring (cdr file))))
  77.            (print (namestring paths)))
  78.        t)
  79.      nil))))
  80.  
  81. ;;;
  82. (dolist (symbol '(ilisp-callers ilisp-source-files))
  83.   (export symbol))
  84. (unless (compiled-function-p #'ilisp-callers)
  85.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  86.